; ORIGINAL: 3dt2.1/examples/zoom.scm
; $Id: zoom.scm,v 1.3 1996/10/21 15:59:49 aed Exp $
;- zoom.scm ------------------------------------------------------
; zoom a view with he mouse
; (zoom #t) turns on zooming, *zoom #f) turns off zooming
;------------------------------------------------------------------
(require 'old-rb "old-rb.scm")

;; Initialize user-modifiable zoom step factor
(define zoom-step 0.1)

(define zoom
  (lambda (onoff)
    (let ((orig-y 0)
          (orig-view #f)
          (orig-width 0)
          (orig-height 0))
      (if onoff
        ;; TRUE: Define mouse hooks for tracking position
        (begin
          ;; When button pressed, save original view info & start tracking
          (set! mouse-down-hook
            (lambda (pe)
              (begin
                (set! orig-y (event:y pe))
                (set! orig-view (event:view pe))
                (set! orig-width (view:width orig-view))
                (set! orig-height (view:height orig-view))
                (rb:scheme #t)
              )
            )
          )

          ;; As mouse moves, update view size and refresh
          (set! rb-update-hook
            (lambda (pe)
              (if orig-view
                (let ((delta (* zoom-step (- (event:y pe) orig-y))))
                  (let ((factor (if (positive? delta)
                                  (+ 1 delta)
                                  (/ 1 (- 1 delta))
                                )))
                    (view:set-size (* orig-width factor)
                                   (* orig-height factor)
                                   orig-view)

                    (view:refresh orig-view)
                  )
                )
                #f
              )
            )
          )

          ;; When button released, stop tracking
          (set! mouse-up-hook
            (lambda (pe)
              (set! orig-view #f)
              (rb:scheme #f)
            )
          )
        )

        ;; FALSE: Turn of tracking capability
        (begin
          (set! mouse-down-hook '())
          (set! mouse-up-hook '())
          (set! rb-update-hook '())
        )
      )

      ;; Return the new setting
      onoff
    )
  )
)

